<%
'无组件上传类
Class FastAsp_Upload
    Private Form, Files
    Private vCharSet, vMaxSize, vSingleSize, vErr, vTotalSize, vExe, vErrExe
    Private vboundary, vLostTime, vMode, vFileCount, StreamOpened
    Private vMuti, vServerVersion
    Private StreamT
    
    Private Sub Class_Initialize()
        Set Form = Server.CreateObject("Scripting.Dictionary")
        Set Files = Server.CreateObject("Scripting.Dictionary")
        Set StreamT = Server.CreateObject("ADODB.Stream")
        
        vCharSet = "iso-8859-1" 'ASCII
        vMaxSize = 100000
        vSingleSize = 100000
        vTotalSize = 0
        vErr = 0
        vExe = "jpg|gif|png|bmp|rar|zip|doc|xls|pdf|txt"
        vErrExe = "asp|asa|aspx|exe|cmd|bat|cer"
        vFileCount = 0
        vMuti = False
        vServerVersion = 6
        
        '如果是上传请求则立即处理
        If Request.TotalBytes > 0 Then
            GetData()
        End If
    End Sub
    
    '获取随机文件名
    Private Function GetName()
        Dim y, m, d, h, mm, s, r
        y = Year(Now())
        m = Month(Now()): If m < 10 Then m = "0" & m
        d = Day(Now()): If d < 10 Then d = "0" & d
        h = Hour(Now()): If h < 10 Then h = "0" & h
        mm = Minute(Now()): If mm < 10 Then mm = "0" & mm
        s = Second(Now()): If s < 10 Then s = "0" & s
        r = Int(Rnd * 10000)
        If r < 1000 Then r = "0" & r
        GetName = y & m & d & h & mm & s & r
    End Function
  
    '获取上传数据
    Private Function GetData()
        On Error Resume Next
        
        Response.Write "Debug: Starting GetData<br>"
        Response.Write "Debug: TotalBytes = " & Request.TotalBytes & "<br>"
        
        If Request.TotalBytes < 1 Then
            Response.Write "Debug: No data received<br>"
            vErr = 4
            Exit Function
        End If
        
        Response.Write "Debug: Reading data in chunks<br>"
        
        ' 读取所有二进制数据
        Dim allData : allData = Request.BinaryRead(Request.TotalBytes)
        Response.Write "Debug: BytesRead = " & LenB(allData) & "<br>"
        
        ' 获取Content-Type和boundary
        Dim contentType : contentType = Request.ServerVariables("HTTP_CONTENT_TYPE")
        If contentType = "" Then
            contentType = Request.ServerVariables("CONTENT_TYPE")
        End If
        Response.Write "Debug: Content-Type = " & contentType & "<br>"
        
        Dim boundaryPos : boundaryPos = InStr(1, contentType, "boundary=")
        If boundaryPos < 1 Then
            Response.Write "Debug: Boundary not found in Content-Type<br>"
            vErr = 3
            Exit Function
        End If
        
        Dim vboundary : vboundary = Mid(contentType, boundaryPos + 9)
        ' 移除引号（如果存在）
        If Left(vboundary, 1) = """" Then
            vboundary = Mid(vboundary, 2, Len(vboundary) - 2)
        End If
        vboundary = "--" & vboundary  ' 添加前导虚线
        Response.Write "Debug: Boundary = [" & vboundary & "]<br>"
        
        ' 转换boundary为字节数组
        Dim boundaryBytes : boundaryBytes = ""
        Dim i
        For i = 1 To Len(vboundary)
            boundaryBytes = boundaryBytes & ChrB(Asc(Mid(vboundary, i, 1)))
        Next
        
        Response.Write "Debug: Boundary length in bytes = " & LenB(boundaryBytes) & "<br>"
        Response.Write "Debug: Total data length in bytes = " & LenB(allData) & "<br>"
        
        ' 显示前100个字节用于调试
        Response.Write "Debug: First 100 bytes of data: "
        For i = 1 To 100
            If i <= LenB(allData) Then
                Response.Write Right("0" & Hex(AscB(MidB(allData, i, 1))), 2) & " "
            End If
        Next
        Response.Write "<br>"
        
        Response.Write "Debug: Boundary bytes: "
        For i = 1 To LenB(boundaryBytes)
            Response.Write Right("0" & Hex(AscB(MidB(boundaryBytes, i, 1))), 2) & " "
        Next
        Response.Write "<br>"
        
        ' 查找第一个边界
        Dim pos : pos = InStrB(1, allData, boundaryBytes)
        If pos = 0 Then
            Response.Write "Debug: No boundary found<br>"
            vErr = 3
            Exit Function
        End If
        
        Response.Write "Debug: First boundary found at position " & pos & "<br>"
        pos = pos + LenB(boundaryBytes)
        
        ' 定义CRLF
        Dim crlfBytes : crlfBytes = ChrB(13) & ChrB(10)
        Dim doubleCrlfBytes : doubleCrlfBytes = crlfBytes & crlfBytes
        
        ' 循环处理每个部分
        Do While pos < LenB(allData)
            ' 跳过CRLF
            If MidB(allData, pos, 2) = crlfBytes Then
                pos = pos + 2
                Response.Write "Debug: Skipped CRLF, new position: " & pos & "<br>"
            End If
            
            ' 查找头部结束位置（两个CRLF）
            Dim headerEnd : headerEnd = InStrB(pos, allData, doubleCrlfBytes)
            If headerEnd = 0 Then 
                Response.Write "Debug: Header end not found<br>"
                Exit Do
            End If
            Response.Write "Debug: Header end found at: " & headerEnd & "<br>"
            
            ' 获取头部信息
            Dim headerBytes : headerBytes = MidB(allData, pos, headerEnd - pos)
            
            ' 转换头部为字符串
            Dim headers : headers = ""
            For i = 1 To LenB(headerBytes)
                headers = headers & Chr(AscB(MidB(headerBytes, i, 1)))
            Next
            
            Response.Write "Debug: Raw headers length = " & LenB(headerBytes) & "<br>"
            Response.Write "Debug: Raw headers = [" & Server.HTMLEncode(headers) & "]<br>"
            
            ' 查找下一个边界
            Dim valueEnd : valueEnd = InStrB(headerEnd + 4, allData, boundaryBytes)
            If valueEnd = 0 Then 
                Response.Write "Debug: Next boundary not found<br>"
                Exit Do
            End If
            Response.Write "Debug: Next boundary found at: " & valueEnd & "<br>"
            
            ' 解析头部信息
            If Len(headers) > 0 Then
                Dim startpos : startpos = InStr(1, headers, "name=""", 1)
                Response.Write "Debug: Name position = " & startpos & "<br>"
                If startpos > 0 Then
                    startpos = startpos + 6 ' 跳过 name="
                    Dim endpos : endpos = InStr(startpos, headers, """")
                    If endpos > 0 Then
                        Dim fieldName : fieldName = Mid(headers, startpos, endpos - startpos)
                        Response.Write "Debug: Field name: " & fieldName & "<br>"
                        
                        ' 检查是否是文件
                        If InStr(headers, "filename=""") > 0 Then
                            startpos = InStr(headers, "filename=""") + 10
                            endpos = InStr(startpos, headers, """")
                            Dim fileName : fileName = Mid(headers, startpos, endpos - startpos)
                            
                            If Trim(fileName) <> "" Then
                                ' 处理文件
                                fileName = Replace(fileName, "/", "\")
                                fileName = Replace(fileName, chr(0), "")
                                Dim localName : localName = fileName
                                fileName = Mid(fileName, InStrRev(fileName, "\") + 1)
                                
                                ' 获取内容类型
                                Dim type_1 : type_1 = InStr(endpos, LCase(headers), "content-type:")
                                Dim content_type : content_type = ""
                                If type_1 > 0 Then
                                    content_type = Trim(Mid(headers, type_1 + 13))
                                End If
                                
                                ' 获取文件内容（去掉结尾的CRLF）
                                Dim fileContent : fileContent = MidB(allData, headerEnd + 4, valueEnd - headerEnd - 6)
                                Response.Write "Debug: File content length = " & LenB(fileContent) & "<br>"
                                
                                ' 创建文件字典
                                Dim fileDict : Set fileDict = Server.CreateObject("Scripting.Dictionary")
                                fileDict.Add "FileName", fileName
                                fileDict.Add "LocalName", localName
                                fileDict.Add "ContentType", content_type
                                fileDict.Add "FileSize", LenB(fileContent)
                                fileDict.Add "Content", fileContent
                                
                                Files.Add fieldName, fileDict
                                vFileCount = vFileCount + 1
                                Response.Write "Debug: File added to collection<br>"
                            End If
                        Else
                            ' 处理普通字段
                            Dim fieldContent : fieldContent = MidB(allData, headerEnd + 4, valueEnd - headerEnd - 6)
                            Dim fieldValue : fieldValue = ""
                            For i = 1 To LenB(fieldContent)
                                fieldValue = fieldValue & Chr(AscB(MidB(fieldContent, i, 1)))
                            Next
                            Form.Add fieldName, fieldValue
                            Response.Write "Debug: Form field added: " & fieldName & " = " & Server.HTMLEncode(fieldValue) & "<br>"
                        End If
                    End If
                End If
            End If
            
            ' 移动到下一个部分
            pos = valueEnd + LenB(boundaryBytes)
            
            ' 检查是否是最后的边界
            If pos + 2 <= LenB(allData) Then
                If MidB(allData, pos, 2) = ChrB(45) & ChrB(45) Then ' "--"
                    Response.Write "Debug: Found final boundary<br>"
                    Exit Do
                End If
            End If
        Loop
        
        Response.Write "Debug: Form fields count = " & Form.Count & "<br>"
        Response.Write "Debug: Files count = " & Files.Count & "<br>"
        
        If Err.Number <> 0 Then
            Response.Write "Debug: Error occurred - " & Err.Description & "<br>"
        End If
    End Function
    
    '获取正则匹配值
    Private Function GetMatchValue(byval str, byval pattern)
        On Error Resume Next
        
        Response.Write "Debug: Matching pattern [" & pattern & "] against [" & Server.HTMLEncode(str) & "]<br>"
        
        Dim reg : Set reg = New RegExp
        reg.Pattern = pattern
        reg.IgnoreCase = True
        reg.Global = False
        
        Dim matches : Set matches = reg.Execute(str)
        If matches.Count > 0 Then
            GetMatchValue = matches(0).SubMatches(0)
            Response.Write "Debug: Found match: " & GetMatchValue & "<br>"
        Else
            GetMatchValue = ""
            Response.Write "Debug: No match found<br>"
        End If
        
        Set reg = Nothing
    End Function
    
    '二进制转字符串
    Private Function BinToStr(byval bin)
        Dim stream : Set stream = Server.CreateObject("ADODB.Stream")
        stream.Type = 1
        stream.Mode = 3
        stream.Open
        stream.Write bin
        
        stream.Position = 0
        stream.Type = 2
        stream.Charset = "iso-8859-1" 'ASCII
        BinToStr = stream.ReadText
        
        stream.Close
        Set stream = Nothing
    End Function
    
    '获取表单数据
    Public Function GetForm(byval name)
        If Form.Exists(name) Then
            GetForm = Form(name)
        Else
            GetForm = ""
        End If
    End Function
    
    '获取文件数据
    Public Function GetFile(byval name)
        If Files.Exists(name) Then
            Set GetFile = Files(name)
        Else
            Set GetFile = Nothing
        End If
    End Function
    
    '保存文件
    Public Function SaveFile(byval name, byval path)
        If Not Files.Exists(name) Then
            vErr = 2
            SaveFile = False
            Exit Function
        End If
        
        On Error Resume Next
        Err.Clear
        
        Dim fileObj : Set fileObj = Files(name)
        Dim fullPath : fullPath = Server.MapPath(path)
        
        '检查并创建目录
        CreateFolder fullPath
        
        Dim targetPath : targetPath = fullPath & "\" & fileObj("FileName")
        
        Response.Write "Debug: 准备写入文件到 " & targetPath & "<br>"
        Response.Write "Debug: Content length = " & LenB(fileObj("Content")) & "<br>"
        
        ' 直接写入二进制文件
        Dim fso, f
        Set fso = CreateObject("Scripting.FileSystemObject")
        
        ' 如果文件已存在，先删除
        If fso.FileExists(targetPath) Then
            fso.DeleteFile targetPath, True
        End If
        
        ' 创建二进制写入流
        Dim stm
        Set stm = CreateObject("ADODB.Stream")
        stm.Type = 1  ' adTypeBinary
        stm.Open
        
        ' 写入二进制数据
        stm.Write fileObj("Content")
        
        ' 保存到文件
        stm.SaveToFile targetPath, 2  ' adSaveCreateOverWrite
        
        If Err.Number <> 0 Then
            Response.Write "Debug: Error saving file - " & Err.Description & "<br>"
            SaveFile = False
        Else
            Response.Write "Debug: 文件写入成功<br>"
            Response.Write "Debug: 文件已保存到 " & targetPath & "<br>"
            SaveFile = True
        End If
        
        stm.Close
        Set stm = Nothing
        Set fso = Nothing
    End Function
    
    '创建文件夹
    Private Sub CreateFolder(byval path)
        On Error Resume Next
        
        Dim fso : Set fso = Server.CreateObject("Scripting.FileSystemObject")
        
        If Not fso.FolderExists(path) Then
            Dim parentPath : parentPath = fso.GetParentFolderName(path)
            If parentPath <> "" And Not fso.FolderExists(parentPath) Then
                CreateFolder parentPath
            End If
            
            fso.CreateFolder path
            If Err.Number <> 0 Then
                Response.Write "Debug: Error creating folder - " & path & " - " & Err.Description & "<br>"
            End If
        End If
        
        Set fso = Nothing
    End Sub
    
    '获取错误信息
    Public Property Get Error_()
        Select Case vErr
            Case 1: Error_ = "文件超过最大限制: " & vMaxSize & "KB"
            Case 2: Error_ = "请选择要上传的文件!"
            Case 3: Error_ = "无法找到边界"
            Case 4: Error_ = "发生错误"
            Case Else: Error_ = ""
        End Select
    End Property
    
    Private Sub Class_Terminate()
        If StreamOpened Then StreamT.Close
        Set StreamT = Nothing
        Set Form = Nothing
        Set Files = Nothing
    End Sub
    
    ' 字符串转字节数组
    Private Function String2Bytes(byval str)
        If str = "" Then 
            String2Bytes = ""
            Exit Function
        End If
        
        Dim stream
        Set stream = Server.CreateObject("ADODB.Stream")
        stream.Type = 2 'adTypeText
        stream.Mode = 3 'adModeReadWrite
        stream.Charset = "iso-8859-1" 'ASCII
        stream.Open
        stream.WriteText str
        stream.Position = 0
        stream.Type = 1 'adTypeBinary
        stream.Position = 0
        String2Bytes = stream.Read
        stream.Close
        Set stream = Nothing
    End Function

    ' 字节数组转字符串
    Private Function Bytes2String(byval bytes)
        If LenB(bytes) = 0 Then
            Bytes2String = ""
            Exit Function
        End If
        
        Dim stream
        Set stream = Server.CreateObject("ADODB.Stream")
        stream.Type = 1 'adTypeBinary
        stream.Mode = 3 'adModeReadWrite
        stream.Open
        stream.Write bytes
        stream.Position = 0
        stream.Type = 2 'adTypeText
        stream.Charset = "iso-8859-1" 'ASCII
        Bytes2String = stream.ReadText
        stream.Close
        Set stream = Nothing
    End Function
End Class
%>